#include "lisp.h"
#include "lisp_globals.h"
#include "gc.h"
#include "area.h"
#include <stdlib.h>
#include <string.h>
#include "lisp-exceptions.h"
#include "loader.h"
#include <stdio.h>
#include <stdlib.h>
#ifdef PMCL_OSX_NATIVE_KERNEL
#include <Carbon/Carbon.h>
#include <sys/types.h>
#include <sys/time.h>
#include <signal.h>
#include <unistd.h>
#include <mach/task.h>
#include <mach/semaphore.h>
#include <sys/sysctl.h>
#include <sys/mman.h>
#include <pthread.h>
#ifdef USE_ALTCONSOLE
#include <altappservices/altappservices.h>
#endif
#else
#include <Folders.h>
#include <timer.h>
#include <FixMath.h>
#include <Gestalt.h>
#include <Resources.h>
#include <QuickDraw.h>
#include <Fonts.h>
#include <TextEdit.h>
#include <Dialogs.h>
#include <Retrace.h>
#include <LowMem.h>
#include <OSUtils.h>
#include <Multiprocessing.h>
#endif

#include "debugf.h"




/*
 $Log: pmcl-kernel.c,v $
 Revision 1.15  2006/02/03 19:59:57  alice
 probably no change

 Revision 1.14  2005/06/26 03:24:47  alice
 remove_tmtask etc

 Revision 1.13  2004/03/03 01:08:59  gtbyers
 Split out the console-opening code so that new console can be opened if death of old one is noticed.

 Revision 1.12  2003/12/08 04:10:08  gtbyers
 Use CFBundle (instead of weak linking) to find "altappservices.framework" at runtime.  (commit to main branch)

 Revision 1.10.2.1  2003/12/03 20:33:18  gtbyers
 Use CFBundle (instead of weak linking) to find "altappservices.framework" at runtime.

 Revision 1.10  2003/11/14 00:20:10  alice
  10/15/03 lisp_heap_size_from_LSIZ_resource - don't exceed 1GB else newhandle will barf

 Revision 1.9  2003/11/10 17:17:51  gtbyers
 Use altappservices to try to setup file descriptors 0,1, and 2, unless they're already set (e.g., by GDB or by running LaunchCFMApp from a terminal.)

 Revision 1.8  2003/08/06 02:44:35  gtbyers
 Initialize cache_block_size (by asking the OS) soon after startup.

 Revision 1.7  2003/02/25 22:41:05  gtbyers
 cmain_vbl: suspend TScurrent_mach_thread (the Mach thread underneath the active cooperative thread) during execution.

 Revision 1.6  2003/02/22 21:20:55  gtbyers
 cmain_vbl() walks the binding stack in native kernel.

 Revision 1.5  2003/02/13 00:48:01  gtbyers
 Lock binding stack around (most of) cmain_vbl() body.

 Revision 1.4  2003/02/12 21:38:53  gtbyers
 Use locks; use the Time Manager.

 Revision 1.3  2003/01/13 20:10:46  gtbyers
 Define the kernel_global NATIVE_KERNEL_VERSION when using the native kernel.  Don't define unused/obsolete MP_* kernel globals, ever.

 Revision 1.2  2002/11/25 06:14:09  gtbyers
 CFM version of set_nil_and_start passes CFM versions of itself and application_loader to native kernel (so SAVE-APPLICATION can cause the CFM versions to be imported from the application.)

 02/28/07 increase egc thresholds
 12/11/06 try to lose need for subprims resource
------ 5.2b6
 06/23/05 add remove_tmtask and restore_tmtask
 06/01/05 forget about preferred-size-from-SIZE-reaource - hardwire 1,000,000,000
---------- 5.1 final
 10/15/03 lisp_heap_size_from_LSIZ_resource - don't exceed 1GB else newhandle will barf
--------- 5.0 final
 12/18/01 akh lisp_heap_size_from_LSIZ_resource uses constant if osx - yech!
 04/01/01 akh no mo splasher
 02/07/01 akh see tb_trap_call for pre carbon
 02/05/01 akh use __appstart if OSX but it doesn't help - tries to ref 0 as does __start
 08/15/00 increase timer interval from 1 to 15 - I think it's millisecs and vbl task was once per tick
 06/28/00 use newtimer if carbon
 04/07/00 no mo  build_routine_xxx if carbon, should check if metering stuff still works - seems ok
 03/03/00 vblq => timerQ
 02/18/00 akh CFragHFSLocatorPtr is undefined in new headers, changed some cfrag names to be new names
 04/17/97 bill  Gary's fix to metering_proc to make it less likely to call
                register_codevector_contains_pc on something that will cause a bug error.
 ---- 4.1b2
 01/29/97 gb    anal-retentive extern decls for gcc.
 ---- 4.0
 09/07/96 gb    try to improve the fragLibNotFound error message.
 ---- 4.0b1
 08/01/96 gb    load_library_or_die: pass plibname vice libname to l().
 07/25/96 bill  slightly de-uglify the message generated by repo_library_load_failure
                by adding a few newlines.
 07/16/96 gb    allocate_lisp_stack tries application heap if MF heap fails.
                load_library_or_die & related changes.
 06/17/96 bill  allocate_lisp_stack gives you exactly as much useable space
                as you ask for. The handle will have up to 4K of wasted space
		and there will be a small unused space after the block.
 06/16/96 bill  allocate_vstack & allocate_tstack allocate 4096 bytes of soft area
                and 0 bytes of hard area.
                allocate_lisp_stack_area initializes soft_area & hard_area to NULL
                so that it will work correctly if its caller passes 0 for softsize or hardsize.
                main allocates the initial tsp & vsp stack with a useable size of
                STACK_SEGMENT_SIZE instead of 1<<16.
 06/26/96 gb    look for tagged *INTERRUPT-LEVEL* symbol in cmain_vbl.  Create ephemeral
                areas.  Fatal errors from loader propagate here.
 06/14/96 slh   continuable_error_dialog: no exit if no dialog
 06/05/96 slh   splash screen
 05/12/96 gb    startup changes for new (non-PEF data) loader.
 ---- 3.9
 04/26/96 gb    account for heap_spare when allocating global_reloctab.
 04/15/96 gb    lisp_heap_size_from_LSIZ: give lisp 2% more (since no static refbits and
                markbits allocated from dynamic heap handle.)
 ---- 3.9f1c2
 04/11/96 gb    allocate_lisp_heap: adjust a->high & a->ndwords when reserving heap_spare.
 04/10/96 gb    new heap allocation stuff.
 04/09/96 gb    use a dialog to warn about missing exception support.
                call set_fpscr to initialize main thread's fpscr.
 04/08/96 bill  initialize EXCEPTION_SAVED_REGISTERS
 03/20/96 gb    second arg to start_lisp.
 03/21/96 bill  lisp_heap_size_from_LSIZ_resource reserves 5% for the mark bits.
                This makes it work leave sufficient Mac heap for all application sizes.
 03/18/96 bill  from gb: "#pragma options align=mac68k" around LSIZ_resource struct definition
 03/18/96 gb    conditionalize out lisp_heap_size_from_LSIZ_resource.  (seemed
                to cause GC failure; not sure why. 
 03/15/96 bill  Use lisp_heap_size_from_LSIZ_resource to determine the
                size of the lisp heap.
 03/15/96 bill  from gb: switch AREA_STATIC & AREA_STATICLIB in
                new new_area calls in set_nil_and_start
 03/01/96 bill  Update comment for cmain_vbl
 03/01/96 gb    protection racket; metering.
 02/20/96 gb    new scheme for all_areas; stop at tb when fixing
                code vectors.
 02/28/96 bill  install_lisp_growzone() just before start_lisp(...)
 02/18/96 bill  allocate_lisp_stack handles NULL value from new_protected_area
 01/29/96 gb    keep track of protected_areas in areas.
 01/26/96 gb    initialize LEXPR_RETURN, LEXPR_RETURN1V
 01/22/96 gb    stack allocation changes.
 01/16/96 gb    allocate_lisp_heap returns handle.
 12/27/95 gb    vbl descriptor in sys heap.
 12/22/95 gb    no MoveHHi (VM thrashes); init READONLY_AREA
 12/13/95 gb    heap allocation changes; main() returns 0.
 11/23/95 bill  start_vbl, cmain_vbl
 11/19/95 gb    no mo SIOW
 10/26/95 slh   set HEAP_START, HEAP_END globals
*/



LispObj lisp_nil = (LispObj) 0;
extern LispObj (start_lisp)(LispObj, LispObj);
extern LispObj *emulator_base;
area *nilreg_area = NULL, *tenured_area = NULL, *g2_area = NULL, *g1_area = NULL;

#ifdef PMCL_OSX_NATIVE_KERNEL
extern LispObj nvalret;
extern LispObj popj;
#endif


unsigned
align_to_power_of_2(unsigned n, unsigned power)
{ 
  unsigned align = (1<<power) -1;
  return (n+align) & ~align;
}



void
relocate_code_vector(LispObj *entry,/* first word past header */
                     unsigned n, /* word count */
                     LispObj bias) /* subprims_base */
{
  LispObj w;
  
  for (;n--;entry++) {
    w = *entry;
    if (w == 0) { 
      break;
    }
    if ((w & BA_MASK) == BA_VAL) {
      *entry = (w + bias);      /* Add it, don't OR it. */
    }
  }
}


void
relocate_dynamic_subprims(LispObj *p, LispObj *q)
{
  LispObj base = lisp_global(SUBPRIMS_BASE);
  
  void * cache_start = (void *) p;
  unsigned ncacheflush = (unsigned) q - (unsigned) p;
  LispObj header;
  
  int nelements, tag, subtag;
  
  while (p < q) {
    header = *p;
    tag = fulltag_of(header);
    if ((tag != fulltag_nodeheader) && (tag != fulltag_immheader)) {
      p += 2;
    } else {
      nelements = header_element_count(header);
      if (tag == fulltag_nodeheader) {
        nelements = (nelements+1+1) & ~1;
        p += nelements;
      } else {
        subtag = header_subtag(header);
        if (subtag == subtag_code_vector) {
          relocate_code_vector(p+1, nelements, base);
        }
        p = (LispObj *) skip_over_ivector((unsigned)p, header);
      }
    }
  }
  mclMakeDataExecutable(cache_start, ncacheflush);  
}
      

#ifdef CARBON
#define StripAddress(p) p
#endif

/* This should write-protect the bottom of the stack.
   Doing so reliably involves ensuring that everything's unprotected on exit.
*/

static BytePtr
allocate_lisp_stack(unsigned useable,
                    unsigned softsize,
                    unsigned hardsize,
                    lisp_protection_kind softkind,
                    lisp_protection_kind hardkind,
                    Handle *h_p,
                    BytePtr *base_p,
                    protected_area_ptr *softp,
                    protected_area_ptr *hardp)
{
  unsigned size = useable+softsize+hardsize;
  unsigned overhead;
  BytePtr base, softlimit, hardlimit;
  OSErr err;
  Handle h = TempNewHandle(size+4095, &err);
  protected_area_ptr hprotp = NULL, sprotp;

  if (err) {
    h = NewHandle(size+4095);
    err = MemError();
    if (err) {
      if (base_p) *base_p = NULL;
      if (h_p) *h_p = NULL;
      return NULL;
    }
  }
  if (h_p) *h_p = h;
  MoveHHi(h);
  HLock(h);
  base = (BytePtr) align_to_power_of_2((unsigned) StripAddress(*h), 12);
  hardlimit = (BytePtr) (base+hardsize);
  softlimit = hardlimit+softsize;

  overhead = (base - (BytePtr) (*h));
  SetHandleSize(h, size + overhead);
  if (hardsize) {
    hprotp = new_protected_area((BytePtr)base,hardlimit,hardkind, hardsize, false);
    if (hprotp == NULL) {
      if (base_p) *base_p = NULL;
      if (h_p) *h_p = NULL;
      DisposeHandle(h);
      return NULL;
    }
    if (hardp) *hardp = hprotp;
  }
  if (softsize) {
    sprotp = new_protected_area(hardlimit,softlimit, softkind, softsize, true);
    if (sprotp == NULL) {
      if (base_p) *base_p = NULL;
      if (h_p) *h_p = NULL;
      if (hardp) *hardp = NULL;
      if (hprotp) delete_protected_area(hprotp);
      DisposeHandle(h);
      return NULL;
    }
    if (softp) *softp = sprotp;
  }
  if (base_p) *base_p = base;
  return (BytePtr) ((unsigned)(base+size));
}

/* This'll allocate a tstack or a vstack, but the thread
   mangler won't let us allocate or reliably protect
   a control stack.
*/
area *
allocate_lisp_stack_area(area_code stack_type,
                         unsigned useable, 
                         unsigned softsize, 
                         unsigned hardsize, 
                         lisp_protection_kind softkind, 
                         lisp_protection_kind hardkind)

{
  BytePtr base, bottom;
  Handle h;
  area *a = NULL;
  protected_area_ptr soft_area=NULL, hard_area=NULL;

  bottom = allocate_lisp_stack(useable, 
                               softsize, 
                               hardsize, 
                               softkind, 
                               hardkind, 
                               &h, 
                               &base,
                               &soft_area, 
                               &hard_area);

  if (bottom) {
    a = new_area(base, bottom, stack_type);
    a->hardlimit = base+hardsize;
    a->softlimit = base+hardsize+softsize;
    a->h = h;
    a->softprot = soft_area;
    a->hardprot = hard_area;
    add_area(a);
  }
  return a;
}

area*
register_cstack(BytePtr bottom, unsigned size)
{
  BytePtr lowlimit = (BytePtr) (((((unsigned)bottom)-size)+4095)&~4095);
  area *a = new_area(lowlimit, bottom, AREA_CSTACK);

  a->hardlimit = lowlimit+(64<<10);
  a->softlimit = lowlimit+(128<<10);
  add_area(a);
  return a;
}
  
area*
allocate_vstack(unsigned useable)
{
  if (useable < (1<<20)) {
    useable = 1<<20;
  }
  return allocate_lisp_stack_area(AREA_VSTACK, 
                                  useable, 
                                  128<<10,
                                  128<<10,
                                  kVSPsoftguard,
                                  kVSPhardguard);
}

area *
allocate_tstack(unsigned useable)
{
  if (useable < (512<<10)) {
    useable = 512<<10;
  }
  return allocate_lisp_stack_area(AREA_TSTACK, 
                                  useable, 
                                  64<<10,
                                  8192,
                                  kTSPsoftguard,
                                  kTSPhardguard);
}

typedef struct LSIZ_resource LSIZ_resource;
typedef LSIZ_resource **LSIZ_handle;

#pragma options align=mac68k
struct LSIZ_resource {
  long mac_heap_minimum;
  long mac_heap_maximum;
  short mac_heap_percentage;
  long low_memory_threshold;
  long copying_gc_threshold;
  long stack_minimum;
  long stack_maximum;
  short stack_percentage;
};
#pragma options align=reset

struct NSIZ_resource {
  unsigned heapsize;
};

typedef struct NSIZ_resource *NSIZ_ptr, **NSIZ_handle;

typedef struct SIZE_resource SIZE_resource;
typedef SIZE_resource **SIZE_handle;

#pragma options align=mac68k
struct SIZE_resource {
  short bits;
  unsigned preferred_size;
  unsigned minimum_size;
  
};
#pragma options align=reset

/* It's hard to believe that max & min don't exist already */
unsigned unsigned_min(unsigned x, unsigned y)
{
  if (x <= y) {
    return x;
  } else {
    return y;
  }
}

unsigned unsigned_max(unsigned x, unsigned y)
{
  if (x >= y) {
    return x;
  } else {
    return y;
  }
}

unsigned
preferred_size_from_SIZE_resource ()
{
  long index = Count1Resources('SIZE');
  SIZE_handle h = (SIZE_handle) Get1IndResource('SIZE', index);
  unsigned result;
  result = (**h).preferred_size;  
  ReleaseResource((Handle) h);
  return result;
}

unsigned
heap_spare_size = 65536;        /* size to hold in reserve */

unsigned
heap_spare = 65536;                 /* size currently held in reserve */

unsigned
lisp_heap_size_from_LSIZ_resource ()
{
  unsigned max_size = 0;
  long resp;
  unsigned real_macheap_size = 0;
  unsigned desired_macheap_size = 0;
  unsigned result;
  unsigned spare;
  LSIZ_handle lsiz = (LSIZ_handle) GetResource('LSIZ', 1);
  NSIZ_handle nsiz = (NSIZ_handle) GetResource('NSIZ', 1);
  
  if (is_osx()) { 
    if (nsiz && *nsiz) {
      max_size = (*nsiz)->heapsize;
    } else {
      max_size=1073000000;
    }
  } 
  else {
    max_size=MaxBlock();
  } 

 	
    unsigned free_bytes = max_size;
    if (is_osx ())  {desired_macheap_size = 0;
    } else {
       desired_macheap_size = 
             (unsigned) (((double)free_bytes) * ((double) (**lsiz).mac_heap_percentage) / 100.0);
       real_macheap_size = 
             unsigned_min((**lsiz).mac_heap_maximum,
                             unsigned_max((**lsiz).mac_heap_minimum, desired_macheap_size));
      }      
   
    result = free_bytes - real_macheap_size - 4095 - heap_segment_size;
    /* spare = ((**lsiz).low_memory_threshold);  forget spare */
    /* 3% for mark bits and other random stuff.  This was 5%, but we're
       not taking the markbits out of a seperate heap block anymore.
     */
    result = (unsigned) (((double) result) / 1.03);
    /*
    if (spare) {
      heap_spare_size = align_to_power_of_2(spare, log2_heap_segment_size); 
    } */
    ReleaseResource((Handle) lsiz);
    return result;
  
}

  

/*
  If size is specified as 0, take lisp_heap_size_from_LSIZ_resource() bytes
  in the application heap.  Otherwise, try to obtain a heap of the specified
  size from MultiFinder temporary memory.
*/

area *
allocate_lisp_heap(unsigned size)
{
  Boolean useMF = (size != 0);
  OSErr err;
  Handle h;
  unsigned base, totalsize;
  BytePtr suffix, end, lastbyte, start, protstart;
  area *a;
  protected_area_ptr softp, hardp;
  bitvector markbits;
  
  if (size == 0) {
    size = lisp_heap_size_from_LSIZ_resource();
  }

  totalsize = 4095+align_to_power_of_2(size+heap_segment_size,log2_heap_segment_size);

  if (useMF) {
    h = TempNewHandle(totalsize, &err);
  } else {
    ReserveMem(totalsize);
    h = NewHandle(totalsize);
    err = MemError();
  }
  if (err) {
    return NULL;                /* caller must check for this! */
  }
  /* MoveHHi(h); */
  HLock(h);
  base = (unsigned) StripAddress(*h);
  lastbyte = (BytePtr) (base+totalsize);
  end = (BytePtr) ((int)lastbyte  & ~4095);
  suffix = end-heap_segment_size;
  hardp = new_protected_area(suffix,end,kHEAPhard, heap_segment_size, false);
  start = (BytePtr) (align_to_power_of_2(base,3));
  /* Allocate mark bits here.  They need to be 1/64 the size of the maximum useable
     area of the heap, or 1/65 its current size.  Round up to a word boundary, add
     three words (for egc, eventually), and align "start" to an 8-byte boundary. */
  markbits = (bitvector) start;
  start += align_to_power_of_2(12+((suffix-start)/65), 3);
  protstart = (BytePtr) (suffix - (((suffix-start)>>log2_heap_segment_size)<<log2_heap_segment_size));
  softp = new_protected_area(protstart,suffix,kHEAPsoft, heap_segment_size, true);
  memset(start,0,protstart-start);
  SetHandleSize(h,totalsize-(lastbyte-end));
  a = new_area(start, suffix, AREA_DYNAMIC);
  add_area(a);
  a->markbits = markbits;
  a->h = h;
  a->softprot = softp;
  a->hardprot = hardp;
  a->hardlimit = hardp->start;
  /* Try to reserve some spare bytes in the hard protected area 
     (by taking them out of the soft area.) */
  if (((softp->end - softp->start) - softp->nprot) > heap_spare_size) {
    softp->end -= heap_spare_size;
    hardp->start -= heap_spare_size;
    a->high -= heap_spare_size;
    a->ndwords -= (heap_spare_size >> 3);
    heap_spare = heap_spare_size;
  }
  return a;
}
   
void
mac_init(void);

/*
  Initialize the Mac.  If using SIOW, tell SIOW that it doesn't
  have to initialize the Mac by setting a bunch of semi-documented
  variables.
*/

#ifdef TTY
#ifndef SIOW
QDGlobals qd;
#endif

#ifdef CONSOLE
void
install_console(void);
#endif
#endif

Ptr gc_cursor = NULL;

Boolean mac_inited = false;

void
mac_init()
{
#ifdef SIOW
  extern 
    Boolean
      __initDialogs,
      __teInit,
      __initMenus,
      __initWindows,
      __initFonts;
#endif
  int i;
  Handle h;
  if (mac_inited == false) {
#ifndef CARBON
    SetApplLimit((BytePtr)&i-(64<<10));
    MaxApplZone();
#endif

    for (i = 0; i < 20; i++) {
      MoreMasters();
    }



#ifdef SIOW
    __initDialogs = 1;
    __teInit = 1;
    __initMenus = 1;
    __initWindows = 1;
    __initFonts = 1;
#endif
#ifdef CONSOLE
    install_console();
#endif
/*    h = Get1Resource('CURS', 336); 
   
    if (h) {
      LoadResource(h);
      DetachResource(h);
      HLock(h);
      gc_cursor = *h;
    } 
*/ 
    mac_inited = true;
  }
}

#ifdef PMCL_OSX_NATIVE_KERNEL
lock_set_t binding_stack_lock_set;
mach_port_t TScurrent_mach_thread = (mach_port_t) 0;
#endif

void lock_binding_stack(void);
void unlock_binding_stack(void);

/* *interrupt-level* is >= 0 when interrupts are enabled and < 0
   during without-interrupts. Normally, it is 0. When this VBL
   goes off, it sets it to 1 if it's 0, or if it's negative,
   walks up the special binding list looking for a previous
   value of 0 to set to 1. 
   Inside Mac says that a VBL will not be run while it's process
   is in the background unless the handler is in the system
   heap. I don't know if this is still true on the PPC.
   The handler is also supposed to be wired into memory, though Gary
   says that VBL's aren't run unless it's OK to swap. */


void
force_mcl_interrupt()
{
  struct lispsymbol *interrupt_level_sym = &nrs_INTERRUPT_LEVEL;
  int interrupt_level = (int) interrupt_level_sym->vcell;

  if (interrupt_level == 0) {
    nrs_INTERRUPT_LEVEL.vcell = 1<<fixnumshift;
  }
}

#ifdef VBL_INTERRUPT


void 
cmain_vbl (TMTaskPtr task)
{
  
  force_mcl_interrupt();
  PrimeTime((QElemPtr)task, 15);


}


#endif

#ifdef ALARM_INTERRUPT
void 
alarm_handler(int signo)
{
  force_mcl_interrupt();
}  

static struct itimerval itimer = {
  {0, 1000000/60},
  {0, 1000000/60}};

void
start_interrupt_timer()
{
  signal(ALARM_SIGNAL, (void *)alarm_handler);
  setitimer(ITIMER_INTERRUPT, &itimer, NULL);
}
  
#endif

#ifdef THREAD_INTERRUPT
/* Use a regular old (preemptively scheduled) thread to periodically
   force MCL interrupts */

void *
interrupt_proc(void *param)
{
  struct timespec interval = {0, 1000000000/60};

  for (;;) {
    if (nanosleep(&interval, NULL) == 0) {
      force_mcl_interrupt();
    }
  }
}

void
start_interrupt_timer()
{
  pthread_attr_t attr;
  pthread_t returned_thread = (pthread_t) 0;

  pthread_attr_init(&attr);
  pthread_attr_setdetachstate(&attr, PTHREAD_CREATE_DETACHED);  

  pthread_create(&returned_thread, &attr, interrupt_proc, NULL);
  pthread_attr_destroy(&attr);
}

void
remove_tmtask()
{
}

void
start_vbl()
{
}

void
restore_tmtask()
{
}
      
#endif
void
lock_binding_stack()
{
#ifdef PMCL_OSX_NATIVE_KERNEL
  lock_acquire(binding_stack_lock_set,0);
#endif
}

void
unlock_binding_stack()
{
#ifdef PMCL_OSX_NATIVE_KERNEL
  lock_release(binding_stack_lock_set,0);
#endif
}



/* This is global so that lib_terminate() can find  & VRemove it */

#ifdef VBL_INTERRUPT
#ifdef CARBON
TMTask *
cmain_vblQ = NULL;
#else
VBLTask *
cmain_vblQ = NULL;
#endif
#endif


/* Likewise. */

#ifdef VBL_INTERRUPT
#ifdef CARBON
TimerUPP cmain_descriptor = NULL;
#else
RoutineDescriptorPtr
cmain_descriptor = NULL;
#endif


/* Start up the VBL task that frobs *interrupt-level* to cause an interrupt. */
void
start_interrupt_timer()
#ifdef CARBON
{
  TMTask *q = (TMTask *) NewPtrClear(sizeof(TMTask));
  /* cmain_descriptor = NewTimerProc(cmain_vbl); */
  cmain_descriptor = (TimerUPP)NewTimerUPP(cmain_vbl);
  
  q->qType = 0;  /* ?? */
  q->tmAddr = cmain_descriptor;
  q->tmCount = 1;
  cmain_vblQ = q;
  InsTime((QElem *) q);
  PrimeTime((QElem *) q, 15);
}
#else
{
  VBLTask *q = (VBLTask *) NewPtrSysClear(sizeof(VBLTask));
  cmain_descriptor = (RoutineDescriptorPtr) NewPtrSysClear(sizeof(RoutineDescriptor));
  BlockMove(&app_heap_descriptor, cmain_descriptor, sizeof(RoutineDescriptor));
  q->qType = vType;
  q->vblAddr = cmain_descriptor;
  q->vblCount = 1;
  cmain_vblQ = q;
  VInstall((QElem *) q);
}
#endif
#endif


extern BytePtr
current_stack_pointer(void);


/*
  Metering thing. This depends on being able to find saved interrupt context
  on the stack.  It seems to be stored #x120 bytes from the SP of metering_proc's
  caller; IWBN if the magic number wasn't hardwired into the code here and
  we had a more kosher way of finding that context.
*/

typedef struct {
  int depth;                    /* So we can set it. */
  int total_hits;
  int lisp_hits;
  int active;
  int interval;
} metering_info;

metering_info
lisp_metering =
{
  0x120, 
  0, 
  0, 
  0, 
  0
  };

typedef struct {
  UnsignedWide machineregs[5];
  UnsignedWide GPRs[32];
  UnsignedWide FPRs[32];
} interrupt_context;
  
#define ic_CR 0
#define ic_XER 1
#define ic_LR 2
#define ic_CTR 3
#define ic_PC 4


void
metering_proc(TMTaskPtr task)
{
  extern interrupt_context* find_interrupt_context(int);
  interrupt_context *context = find_interrupt_context(lisp_metering.depth);

  lisp_metering.total_hits++;
  if (context) {
    if (context->GPRs[rnil].lo == lisp_nil) {
      unsigned current_lisp = lisp_metering.lisp_hits, element;
      LispObj 
        pc = context->machineregs[ic_PC].lo,
      rfn = context->GPRs[fn].lo,
      rnfn = context->GPRs[nfn].lo,
      reg,
      v =  nrs_ALLMETEREDFUNS.vcell;

      if (area_containing((BytePtr)rfn) == NULL) {
        rfn = (LispObj) 0;
      }
      if (area_containing((BytePtr)rnfn) == NULL) {
        rnfn = (LispObj) 0;
      }

      if (tag_of(pc) == tag_fixnum) {
        if (register_codevector_contains_pc(rfn, pc)) {
          reg = rfn;
        } else if (register_codevector_contains_pc(rnfn, pc)) {
          reg = rnfn;
        } else {
          reg = pc;
        }
        element = current_lisp % lisp_metering.active;
        lisp_metering.lisp_hits++;
        deref(v,element+1) = reg; /* NOT memoized */
      }
    }
  }
      
  PrimeTime((QElemPtr)task, lisp_metering.interval);
}



TimerUPP
metering_descriptor = NULL;


TMTask 
metering_task =
{
  NULL,
  0,
  NULL,
  0,
  0,
  0
  };


int
metering_control(int interval)
{ if (metering_descriptor == NULL)
   { 
#ifndef CARBON 
     metering_descriptor = NewTimerProc(metering_proc);
#else
     metering_descriptor = (TimerUPP)NewTimerUPP(metering_proc);
#endif
     metering_task.tmAddr = metering_descriptor;
   }
  if (interval) {
    if (! lisp_metering.active) {        
      LispObj amf = nrs_ALLMETEREDFUNS.vcell;
      if (fulltag_of(amf) == fulltag_misc) {
        unsigned header = header_of(amf);

        if (header_subtag(header) == subtag_simple_vector) {
          InsTime((QElemPtr) &metering_task);
          lisp_metering.interval = interval;
          lisp_metering.active = header_element_count(header);
          lisp_metering.total_hits = 0;
          lisp_metering.lisp_hits = 0;
          
          PrimeTime((QElemPtr) &metering_task, interval);
          return 0;
        }
      }
    }
    return -1;
  }  else {
    if (lisp_metering.active) {
      RmvTime((QElemPtr)&metering_task);
      lisp_metering.active = 0;
      return 0;
    } else {
      return -1;
    }
  }
}


Boolean
continuable_error_dialog(StringPtr param0, 
                         StringPtr param1, 
                         StringPtr param2, 
                         StringPtr param3)
{
  DialogRef the_dialog = GetNewDialog(1066, NULL, (WindowPtr)-1);
  short whichitem;
  if (the_dialog == NULL) {
    /* exit(1); */
    return true;   /* let users remove dialog resource to avoid it */
  }
  ParamText(param0, param1, param2, param3);
#ifdef CARBON
  ShowWindow(GetDialogWindow (the_dialog));
#else
  ShowWindow (the_dialog);
#endif
  ModalDialog(NULL, &whichitem);
#ifndef CARBON
  CloseDialog(the_dialog);
#else
  DisposeDialog(the_dialog);
#endif
  return whichitem==1;
}
  
Handle fatal_spare_handle = NULL;

void
prepare_for_the_worst()
{
  fatal_spare_handle = NewHandle(4096);
  /* I guess that CouldDialog is no more */
  /* CouldDialog(666); */
}

void
Fatal(StringPtr param0, StringPtr param1)
{
  DialogRef the_dialog;
  short whichitem;

  if (fatal_spare_handle) {
    DisposeHandle(fatal_spare_handle);
    fatal_spare_handle = NULL;
  }
  the_dialog = GetNewDialog(666, NULL, (WindowPtr)-1);
  if (the_dialog != NULL) {
    ParamText("\pFatal error in ", LMGetCurApName(), param0, param1);
#ifdef CARBON
  ShowWindow(GetDialogWindow (the_dialog));
#else
  ShowWindow (the_dialog);
#endif
    
    ModalDialog(NULL, &whichitem);
#ifndef CARBON
    CloseDialog(the_dialog);
#else
    DisposeDialog(the_dialog);
#endif
  }
  exit(-1);
}

#define kSplashDialogID 128
#define in_front ((WindowPtr)-1)

void Splasher(void) {
/* so debuggingcarbonlib will shut up because there is no such dialog */
#if 0 
  DialogPtr splash_screen = GetNewDialog(kSplashDialogID, (Ptr)NULL, in_front);
  
  if (splash_screen) {
    DrawDialog( splash_screen );
  }
#endif
  /* Use Lisp code to DisposeWindow the splash screen when we're done with it,
     which is when the application is up and running */
}

extern OSErr (* our_CallOSTrapUniversalProc) (UniversalProcPtr, unsigned, ...);
extern OSErr (* our_CallUniversalProc) (UniversalProcPtr, unsigned, ...);

OSErr application_load_err = noErr;

#ifdef PMCL_OSX_NATIVE_KERNEL
void
get_cache_block_size()
{
  extern int cache_block_size;
  unsigned value = 0;
  size_t len = sizeof(value);
  int mib[2];
    
  mib[0] = CTL_HW;
  mib[1] = HW_CACHELINE;
  if (sysctl(mib,2,&value,&len, NULL, 0) != -1) {
    if (len == sizeof(value)) {
      cache_block_size = value;
    }
  }
}
#endif

Boolean can_use_stdio = false;
Boolean using_alt_console = false;
int (*ourInstallConsole)(int) = NULL;

Boolean
open_alt_console()
{
#ifdef USE_ALTCONSOLE
  int fd = ourInstallConsole(ALT_CONSOLE_BACKEND_DEFAULT);
      
  if (fd >= 0) {
    dup2(fd,0);
    dup2(fd,1);
    dup2(fd,2);
    setvbuf(stdout, NULL, _IONBF, 0);
    setvbuf(stderr, NULL, _IONBF, 0);
    return true;
  }
  return false;
#else
  return false;
}

#endif

void
setup_stdio()
{
#ifdef PMCL_OSX_NATIVE_KERNEL
  if (isatty(0) && isatty(1)) {
    can_use_stdio = true;
  } else {
#ifdef USE_ALTCONSOLE
    unsigned char *bundlepath = "/Library/Frameworks/altappservices.framework";
    CFURLRef url = NULL;
    CFBundleRef altappservicesbundle = NULL;

    url = CFURLCreateFromFileSystemRepresentation(NULL,
                                                  bundlepath,
                                                  strlen(bundlepath),
                                                  true);
    
    if (url) {
      altappservicesbundle = CFBundleCreate(NULL, url);
    }

 if (altappservicesbundle && CFBundleLoadExecutable(altappservicesbundle)) {
      (void *) ourInstallConsole =
        CFBundleGetFunctionPointerForName(altappservicesbundle,
                                          CFSTR("installAltConsole"));
    }
    if (ourInstallConsole != NULL) {
      if (open_alt_console()) {
	using_alt_console = true;
	can_use_stdio = true;
	signal(SIGPIPE, SIG_IGN);
      }
    }
#endif
  }
#endif
}


Boolean
running_under_rosetta()
{
  static Boolean checked = false, on_rosetta = false;

  if (! checked) {
    char *machtype = getenv("MACHTYPE");

    /* May be a more reliable way using sysctl */ 
    if ((machtype != NULL) && (*machtype != 'p')) {
      on_rosetta = true;
    }
    checked = true;
  }
  return on_rosetta;
  
}

extern opcode spjump_start, spjump_end;

void
fix_subprims()
{
  area *a;
  
  for (a = all_areas->succ; a != all_areas; a = a->succ) {
    if (a->code == AREA_READONLY) {
      pc old = &spjump_start, new = ((pc)(a->low))+2;
      opcode instr;
      LispObj target;
      int disp;
      LogicalAddress base = (LogicalAddress)(((LispObj)a->low) &~4095);

      mprotect(base,0x2000,PROT_READ|PROT_WRITE);
      for (old = &spjump_start, new = ((pc)(a->low))+2;
           ;
           old++, new++) {
        if (old == &spjump_end) {
          break;
        }
        instr = *new;
        if (((unsigned)instr>>26) != 18) { /* major_opcode_B */
          break;
        }
        instr = *old;
        disp = instr & ((1<<26)-1);
        target = (LispObj)old+disp;
        *new = ((instr >> 26) << 26) | 2 | (target & ((1<<26)-1));
      }
      mclMakeDataExecutable(base,0x2000);
      mprotect(base,0x2000,PROT_READ|PROT_EXEC);
    }
  }
}

      
main()
{
  extern Boolean exception_filter_installed_p(void);
  extern void pseudo_xalloc(unsigned, ExceptionInformation *);
  extern void set_fpscr(unsigned);
  long resp;
  extern LispObj import_ptrs_base;
  BytePtr heap_start, heap_end, stack_end;
  area *a;
  LispObj curs;

  setup_stdio();
  mac_init();
  prepare_for_the_worst();
  /* DebugStr ("\pzz00"); */

#ifdef PMCL_OSX_NATIVE_KERNEL
  get_cache_block_size();
#endif
  check_for_altivec();
  init_mac_threads();
  
  
#if 0
  /* This can't happen with the new exception mechanism installed. */
  if ((!exception_filter_installed_p())) {
    if (!continuable_error_dialog
        ("\pDebuggers may interfere with normal execution of ",
         LMGetCurApName(),
         "\p because the extension named 'PPCExceptionEnabler' wasn't installed ",
         "\pin the 'Extensions' folder at system startup.  Do you want to continue ?")) {
      exit(-1);
    }
  }
#endif

#ifndef CARBON /* or do we mean emulator_base */
  if (*emulator_base == 0) {
    Fatal("\p:  Can't determine 68K emulated context address.  Shouldn't have to...","\p");
  }
#endif

  if (lisp_global(SUBPRIMS_BASE) == 0) {
    Fatal("\p: Couldn't load subprims library into system heap.", "\pSystem heap full ?");
  }

  if (application_load_err != noErr) {
    Fatal("\p: Error loading application data.", (load_error_message != NULL) ? load_error_message : (StringPtr) "\pUnknown.");
  }

  set_fpscr(0xD0);

  Splasher();

  lisp_global(KERNEL_IMPORTS) = (LispObj) import_ptrs_base;
  if (lisp_global(SAVE_FREEPTR) == 0) {
    a = allocate_lisp_heap(0);
    if (a == NULL) {
      Fatal("\p: Couldn't allocate lisp heap; memory must be VERY tight.", "\p");
    }
    lisp_global(SAVE_FREEPTR) = (LispObj) (a->low);
    set_heap_limit(NULL, a->active);
  } else {
    a = active_dynamic_area;
  }
  heap_start = a->low;
  heap_end = a->high;

  lisp_global(METERING_INFO) = (LispObj) &lisp_metering;
  *(double *) &(lisp_global(DOUBLE_FLOAT_ONE)) = (double) 1.0;
  lisp_global(EXCEPTION_SAVED_REGISTERS) = (LispObj) 0;

  lisp_global(XALLOC) = (LispObj)pseudo_xalloc;  
  global_reloctab = (LispObj *) NewPtr(sizeof(LispObj)*((((a->ndwords)+(heap_spare>>3)+31)>>5)+1));
  if (global_reloctab == NULL) {
    global_reloctab = (LispObj *) 
      alloc_handle_critical(sizeof(LispObj)*((((a->ndwords)+(heap_spare>>3)+31)>>5)+1), false);
  }
  
  lisp_global(HEAP_START) = (LispObj) heap_start;
  lisp_global(HEAP_END) = (LispObj) heap_end;

  if (nilreg_area != NULL) {
    BytePtr lowptr = (BytePtr) a->low;

    a = active_dynamic_area;
    /* Create these areas as AREA_STATIC, change them to AREA_DYNAMIC */
    g1_area = new_area(lowptr, lowptr, AREA_STATIC);
    g2_area = new_area(lowptr, lowptr, AREA_STATIC);
    tenured_area = new_area(lowptr, lowptr, AREA_STATIC);
    add_area(tenured_area);
    add_area(g2_area);
    add_area(g1_area);

    g1_area->code = AREA_DYNAMIC;
    g2_area->code = AREA_DYNAMIC;
    tenured_area->code = AREA_DYNAMIC;

/*    a->older = g1_area; */ /* Not yet: this is what "enabling the EGC" does. */
    g1_area->younger = a;
    g1_area->older = g2_area;
    g2_area->younger = g1_area;
    g2_area->older = tenured_area;
    tenured_area->younger = g2_area;
    tenured_area->refbits = a->markbits;
    lisp_global(TENURED_AREA) = (LispObj)tenured_area;
    g2_area->threshold = (4<<20);  /* was (1<<18) 256K */
    g1_area->threshold = (2<<20); /* 2048K */
    a->threshold = (1<<20);     /* 1024K */
    lisp_global(REFBITS) = (LispObj)(tenured_area->refbits);
  }

      
  a = allocate_vstack(STACK_SEGMENT_SIZE);
  stack_end = a->high;
  lisp_global(SAVE_VSP) = (LispObj) stack_end;
  lisp_global(CURRENT_VS) = (LispObj) a;
  lisp_global(VS_OVERFLOW_LIMIT) = (LispObj)(a->softlimit);

  a = allocate_tstack(STACK_SEGMENT_SIZE);
  stack_end = a->high;
  lisp_global(SAVE_TSP) = (LispObj) stack_end;
  lisp_global(CURRENT_TS) = (LispObj) a;
  lisp_global(TS_OVERFLOW_LIMIT) = (LispObj)(a->softlimit);

  a = register_cstack(current_stack_pointer(), StackSpace());
  lisp_global(CURRENT_CS) = (LispObj) a;
  lisp_global(CS_OVERFLOW_LIMIT) = (LispObj) (a->softlimit);

  lisp_global(OS_TRAP_CALL) = (LispObj) our_CallOSTrapUniversalProc;  /* I dont think this is used - is for emu traps */
#ifndef CARBON
  lisp_global(TB_TRAP_CALL) = (LispObj) CallUniversalProc;   /* used for emulated stack traps - no mo if CARBON */
#else
  lisp_global(TB_TRAP_CALL) = (LispObj) our_CallUniversalProc;
#endif
  if (!is_osx())
     {
     lisp_global(EMULATOR_REGISTERS) = *emulator_base;
     }

  Gestalt(gestaltOSTable,&resp);
  lisp_global(OS_TRAP_BASE) = (LispObj) resp;

  Gestalt(gestaltToolboxTable,&resp);
  lisp_global(TB_TRAP_BASE) = (LispObj) resp;

  lisp_global(APPMAIN) = is_osx() ? 1<<fixnumshift : 0;
#ifdef PMCL_OSX_NATIVE_KERNEL
  lisp_global(NATIVE_KERNEL_VERSION) = PMCL_OSX_NATIVE_KERNEL << fixnumshift;
  lock_set_create(mach_task_self(),
		  &binding_stack_lock_set,
		  1,
		  SYNC_POLICY_FIFO);
#endif
  if (getenv("OAH_GDB") == NULL) {
    start_interrupt_timer();
  }
  install_lisp_growzone();

  fix_subprims();

  /*  DebugStr("\pTostart"); */ 
#ifdef PMCL_OSX_NATIVE_KERNEL
  /*  Debugger(); */
   start_lisp(lisp_nil, 0);
  /* call_cfm_proc(start_lisp, lisp_nil, 0); */
#else
  start_lisp(lisp_nil, 0);   /* I think we got to here starting on OSX */
#endif
  return 0;
}


#ifdef CARBON
void
__appstart(void);
#endif

#ifndef PMCL_OSX_NATIVE_KERNEL
void
__start(void);
#endif

mutable_data_section_header **next_libP = NULL;
unsigned next_libnum = 0;


/* At some point, it might be nice if this could give the user
   some options - such as looking for a misplaced library elsewhere,
   killing off processes to make more MF memory available, etc.
   That's the idea of passing in the "pConnID" argument, but 
   it's ignored for now.
*/

OSErr
report_library_load_failure(OSErr err, CFragConnectionID *pConnID, Str255 failfragname)
{
  unsigned char buf[256];
  char *error_text;
#ifdef SUPPORT_PRAGMA_UNUSED
#pragma unused(pConnID)
#endif

  /* We don't really want to imply that this is continuable.
     We also don't really want to be modal, since the only
     hope the user has of making the library loadable would
     involve -doing something- : moving the library to where
     it could be found, freeing up some memory, searching
     for it and loading it via GetDiskFragment(), whatever ... */
  
  switch (err) {
  case cfragNoLibraryErr : error_text = "library not found on search path, or was found but wouldn't fit in memory"; break;
  case cfragNoClientMemErr : error_text = "not enough (temporary) memory to load library"; break;
  case cfragNoPrivateMemErr: error_text = "not enough memory for internal bookkeeping"; break;
  default: error_text = "Unknown error."; break;
  }

#ifdef CARBON
  debugf (":\nError loading required library:\nerror = %d (%s),\nlibrary name = ", err, error_text);
#else
  DebugStr("\plibrary_load_failure");
#endif
  sprintf((char *)buf, ":\nError loading required library:\nerror = %d (%s),\nlibrary name = ", err, error_text);
#ifdef CARBON
  c2pstrcpy(buf,(char *)buf);
#else
  c2pstr(buf);
#endif
  failfragname[0] -= 9;
  Fatal((StringPtr)buf, failfragname);
  exit (-1);
  return -1;
}

void
load_library_or_die(mutable_data_section_header *libP)
{
  if (libP->immutable_low == (BytePtr)kUnresolvedCFragSymbolAddress) {
    /* The OS couldn't load the library.  There's probably
       no good reason to think that we can, but we may be
       able to generate a more informative error message. */
    unsigned char *libname = (unsigned char *) (libP->libname);
    Str63 plibname;
    Str255 failname;
    OSErr err;
    Ptr mainaddr, data_start;
    CFragConnectionID conn;
    CFragSymbolClass sclass;


    strcpy((char *) plibname, (char *)libname);
#ifdef CARBON
    c2pstrcpy((unsigned char *)plibname, (char *)plibname);
#else
    c2pstr(plibname);
#endif
    do {
      /* Could maybe try SFGetFile + GetDiskFragment as well */
      err = GetSharedLibrary(plibname, kPowerPCCFragArch, kLoadCFrag, &conn, &mainaddr, failname);
      if (err != noErr) {
        err = report_library_load_failure(err, &conn, failname);
      }
    } while (err != noErr);

    /*
      If we got here, the library (somehow) got itself opened and "conn" is a valid 
      connectionID.  Manually import the symbol "data1", and use it to initialize
      libP->low & libP->high. */
    err = FindSymbol(conn, "\pdata1", &data_start, &sclass);
    if (err != noErr) {
      Fatal("\pCan't import data from library ", plibname);
    }
    libP->immutable_low = (void *)data_start;
    /* I don't know why gcc doesn't like doing this the easy way. */
    libP->immutable_high += ((int) data_start);
  }
}

#ifdef CARBON
extern MPTaskID gMPTaskID;
extern MPQueueID gMPQueueID;
#endif

area *
set_nil(LispObj r)
{
  extern LispObj subprims_base;
  extern LispObj subprims_end;
  extern LispObj ret1valn;
  extern LispObj lexpr_return;
  extern LispObj lexpr_return1v;
  static_header *static_headerP;
  area *root, *a, *primary;
  mutable_data_section_header *libP;
  BytePtr low, high;
  unsigned libnum = 2;
  /* DebugStr ("\pone"); */
  if (lisp_nil == 0) {
    root = new_area(NULL, NULL, AREA_VOID);
    if (root == NULL) {
      exit(-1);
    }

    /* The root of all evil is initially linked to itself. */
    root->succ = root->pred = root;
    all_areas = root;

    lisp_nil = r;
#ifndef PMCL_OSX_NATIVE_KERNEL
    lisp_global(SUBPRIMS_BASE) = subprims_base;
    lisp_global(RET1VALN) = ret1valn;   /* ??? */
    lisp_global(LEXPR_RETURN) = lexpr_return;
    lisp_global(LEXPR_RETURN1V) = lexpr_return1v;
#else
  lisp_global(SUBPRIMS_BASE) = (LispObj)&spjump_start;   /* (LispObj)(5<<10);   a random number?? */
  lisp_global(SUBPRIMS_END)  = (LispObj)&spjump_end;
  lisp_global(RET1VALN) = (LispObj)&ret1valn;     /* & */
  lisp_global(LEXPR_RETURN) = (LispObj)&nvalret;
  lisp_global(LEXPR_RETURN1V) = (LispObj)&popj;
#endif
    /* DebugStr ("\pin-set-nil"); */

    static_headerP = (static_header *) (&(lisp_global(STATIC_HEAP_START)));
    next_libP = &(static_headerP->next);

    low = static_headerP->low;
    high = static_headerP->high;
    
    primary = new_area(low, high, AREA_STATIC);
    add_area(primary);

  /* ???? */
    relocate_dynamic_subprims((LispObj *) (low),
                              (LispObj *) (high));


    for (libP = static_headerP->next; libP; libP = libP->next) {
      BytePtr *lowP;
      
      load_library_or_die(libP);
      low = libP->mutable_low;
      a = new_area(low, libP->mutable_high, AREA_STATIC);
      a->owner = libnum;
      add_area(a);

      low = libP->immutable_low;
      lowP = (BytePtr *) low;
      a = new_area(low, libP->immutable_high, AREA_STATICLIB);
      a->owner = libnum;
      add_area(a);

      a = new_area(lowP[0], lowP[1], AREA_READONLY);
      a->owner = libnum;
      add_area(a);


      libnum++;
      next_libP = &(libP->next);
    }

    next_libnum = libnum;

    static_headerP = (static_header *) (&(lisp_global(READONLY_SECTION_START)));
    if (static_headerP->low) {
      add_area(new_area(static_headerP->low, static_headerP->high, AREA_READONLY));
    }

    lisp_global(ALL_AREAS) = (LispObj) all_areas;
    return primary;
  }
  return NULL;
}

void
mclMakeDataExecutable(void *addr, unsigned long len)
{
  extern void MakeDataExecutable(void *, unsigned long);
  
  if (! running_under_rosetta()) {
    MakeDataExecutable(addr,len);
  }
}


LispObj init_code_vector = 0;

OSErr
application_loader(CFragInitBlockPtr initblk, LispObj r)
{
  /* CFragHFSLocatorPtr loc = &(initblk->fragLocator); OLDROUTINENAMES ?? */
  CFragSystem7LocatorPtr loc = &(initblk->fragLocator); 
  CFragLocatorKind where = loc->where;
#ifndef PMCL_OSX_NATIVE_KERNEL
  extern OSErr (*native_application_loader)(CFragInitBlockPtr,LispObj);
  if (native_application_loader) {
    return native_application_loader(initblk, r);
  }
#endif

  init_code_vector = deref(r,0);
  deref(r, 0) = 0;

  mac_init();

  nilreg_area = set_nil(r);


  if (where == kDataForkCFragLocator) {
    FSSpecPtr fss = loc->u.onDisk.fileSpec;
    short refnum;
    long pos;
    area *a;

    application_load_err = FSpOpenDF(fss, fsRdPerm, &refnum);
    if (application_load_err) {
      return noErr;
    }
    pos = loc->u.onDisk.offset+loc->u.onDisk.length;
    application_load_err = SetFPos(refnum, fsFromStart, pos);
    if (application_load_err) {
      return noErr;
    }
    a = allocate_lisp_heap(0);
    application_load_err = load_application_data(a, refnum, pos);
    lisp_global(SAVE_FREEPTR) = (LispObj) (a->active);
    if (application_load_err == noErr) {
      application_load_err = FSClose(refnum);
    }
  }
  return noErr;
}
